00100	TITLE	MKVIC  -  MAKE A VIDEO INTENSITY CONTOUR  -  AUGUST 1972.
00200	
00300	COMMENT/
00400	MEMORY:
00500		TVBUF		216 lines of 288 columns.
00600		PAC
00700		HSEG
00800		VSEG
00900	
01000	PROCESS:
01100	
01200		MKIMAGE		lo, hi, del or vector of thresholds.
01300		THRESHOLD	Generate 1-bit Image.
01400		PACXOR		Rook's move exclusive OR'ing.
01500		MKVIC		make video intensity contours.
01600		HVCONT		contrast of contours.
01700		KLBABY		Kill baby VIC & baby criterion.
01800		MKARCS		Make Arcs - width proportional to constrast.
01900		FARCL		Fit Arcs Linear.
02000		SPLARC		Spline Arcs.
02100	
02200	/
02300	
02400		VSEG:	BLOCK =1729
02500		HSEG:	BLOCK =1736
02600		EXTERN PAC
02700		ISAVED: 0
02800	
02900	INTERN FLGSIX↔FLGSIX: -1 ;FLAG -1 FOR SIX BIT TV, 0 FOR FOUR BIT TV.
03000	INTERN VCUT↔VCUT: 14;VERTEX CONTRAST THRESHOLD.
03100	INTERN FLGXXX↔FLGXXX: 0;enable MKARCS diagonostic display.
03200	
03300	;ARC WIDTH PROPORTIONAL TO CONTRAST TABLE FOR MKARCS.
03400	ARCWID:
03500		FOR I←0,12{6.0↔}
03600		FOR I←13,17{2.0↔}
03700		FOR I←20,37{1.0↔}
03800		FOR I←40,77{0.7↔}
03900		0
     

00100	;PACXOR - MKVIC INITIALIZATION.
00200	SUBR(PACXOR)
00300	BEGIN PACXOR
00400		I←2
00500		SLAPZ PAC↔LIM HSEG↔BLT HSEG+=1727
00600		SLAPZ PAC↔LIM VSEG↔BLT VSEG+=1727
00700		SETZ I,
00800		LAP PAC↔DAP L+2
00900	L:	TRNN I,7↔SETZ 1,↔LAC PAC(I)
01000		XORM HSEG+8(I)	; HSEG bits are above PAC bits.
01100		ROTC -1↔ROT 1,1
01200		XORM VSEG(I)	; VSEG are left of PAC bits.
01300		AOS I
01400		CAIE I,=1728
01500		GO L
01600		SETZM ISAVED
01700		RET0
01800	BEND
01900	
02000	
02100	; RPEV - LINK NAMES.
02200	
02300		DEFINE CW (A,Q){CAR A,1(Q)} ↔ DEFINE CCW (A,Q){CDR A,1(Q)}
02400		DEFINE CW.(A,Q){DIP A,1(Q)} ↔ DEFINE CCW.(A,Q){DAP A,1(Q)}
02500		DEFINE ARC(A,Q){CDR A,0(Q)} ↔ DEFINE ARC.(A,Q){DAP A,0(Q)}
02600		DEFINE ROW(A,Q){CAR A,-1(Q)}↔DEFINE COL(A,Q){CDR A,-1(Q)}
02700	
02800	; ROW-COL FIXED POINT 0000.00 OPERATIONS.
02900		OPDEF FLO[FSC 225]
     

00100	;CHEAP AD HOC DYNAMIC FREE STORAGE ROUTINES.
00200		EXTERN CORGET;
00300		CORSIZ: 0
00400		NIL←777777
00500		AVAIL:	NIL
00600	; PTR ← GETBLK;
00700	GETBLK:
00800	BEGIN GETBLK
00900		ACCUMULATORS{PTR,SIZ}
01000		CDR 1,AVAIL
01100		CAIN 1,NIL↔GO L1
01200		CDR (1)↔DAP AVAIL
01300		SETZM 0(1)↔SETZM 1(1)↔SETZM 2(1)↔SETZM 3(1)
01400		MOVEI 4↔ADDM CORSIZ
01500		ADDI 1,1↔RET0
01600	;GET A BIG BLOCK FROM SAIL.
01700	L1:	LAC [XWD 2,AC2]↔BLT AC15
01800		MOVEI 3,=4096
01900		CALL CORGET
02000		GO[FATAL(NO MORE CORE.)]
02100		MOVEI NIL↔DAP (2)↔SUBI 3,4
02200	L2:	LAC 2↔ADDI 2,4↔DAP(2)↔SUBI 3,4↔JUMPN 3,L2
02300		DAP 2,AVAIL
02400		LAC [XWD AC2,2]↔BLT 15
02500		GO GETBLK
02600	BEND
02700	
02800	;RELBLK(PTR);
02900	RELBLK:
03000	BEGIN RELBLK
03100		LAC 1,ARG1↔SUBI 1,1
03200		SETZM 0(1)↔SETZM 1(1)↔SETZM 2(1)↔SETZM 3(1)
03300		LAC 2,AVAIL↔DAP 2,(1)↔DAP 1,AVAIL
03400		NIM -4↔ADDM CORSIZ
03500		RET1
03600	BEND
03700	
03800	;KLPGON(P)
03900	SUBR(KLPGON)
04000	BEGIN KLPGON
04100		ACCUMULATORS{A2,PGN,E0,Q,R}
04200		LAC PGN,ARG1
04300		CAR E0,1(PGN)
04400		CALL RELBLK,PGN
04500		DAC E0,Q
04600	L:	CCW R,Q
04700		CALL RELBLK,Q
04800		CAMN R,E0↔RET1
04900		DAC R,Q↔GO L
05000	BEND
     

00100	;THRESHOLD(CUT)  -  pre-Foonly Version.
00200	SUBR(THRESH)
00300	BEGIN THRESH
00400		EXTERN PAC,TVBUF
00500		I←13 ↔ J←14 ↔ PTR←15
00600		LAC [XWD L,2]↔BLT 11
00700		LAP 4,ARG1↔SLIMZ I,-=1728
00800		HRLZI PTR,440600  ; =36 BITS TO GO, 6 BITS PER BYTE.
00900		SKIPN FLGSIX↔ HRLZI PTR,440400  ;  4 BITS PER BYTE.
01000		LAP PTR,TVBUF
01100		LAP 7,PAC↔GO 2
01200	
01300	;ACCUMULATOR LOOP.
01400	L:	MOVEI J,=36	;2
01500		ILDB PTR	;3
01600		SUBI ;CUT	;4
01700		ROTC 1		;5
01800		SOJG J,3	;6
01900		SETCAM 1,PAC(I) ;7
02000		AOBJN I,2	;10
02100		POP1J		;11
02200	BEND
02300	
02400	SUBR(HISTOGRAM)
02500	BEGIN HISTOGRAM
02600		EXTERN TVBUF,HISTO
02700		PTR←15
02800	
02900		LAC 1,HISTO↔SETZM(1)	;CLEAR HISTOGRAM.
03000		HRLZ 1↔ADDI 1(1)↔BLT =65(1)
03100	
03200		LAC[XWD L,2]↔BLT 5
03300	
03400		HRLZI PTR,440600↔SKIPN FLGSIX
03500		HRLZI PTR,440400↔LAP PTR,TVBUF
03600		MOVEI =60368	;NUMBER OF PIXELS IN A PICTURE.
03700		ADD 3,HISTO	;HISTOGRAM POINTER.
03800		JRST 2
03900	
04000	;ACCUMULATOR LOOP.
04100	L:	ILDB 1,PTR	;2
04200		AOS 1(1)	;3
04300		SOJG 2		;4
04400		POP1J		;5
04500	BEND
     

00100	;PTR ← PIXPTR(ROW,COL)   -  COMPUTE PICTURE BYTE POINTER.
00200	SUBR(PIXPTR)
00300	BEGIN PIXPTR
00400		;AC-0 PC return address for JSP entry.
00500		;AC-1 Row argument, byte pointer value.
00600		;AC-2 Column argument.
00700		;AC-3 get clobbered.
00800		SETZ↔LAC 1,ARG2↔LAC 2,ARG1
00900	;PIXPTR+3:
01000		SKIPN FLGSIX↔JRST L
01100	;SIX BIT BYTES  -  TVBUF + ROW*48 + (COL DIV 6).
01200		IMULI 1,=48
01300		ADD 1,TVBUF
01400		IDIVI 2,6
01500		ADD  1,2
01600		HLL   1,[POINT 6,0,-1 ↔ POINT 6,0,05 ↔ POINT 6,0,11
01700			 POINT 6,0,17 ↔ POINT 6,0,23 ↔ POINT 6,0,29](3)
01800		JUMPN@↔POP2J
01900	;FOUR BIT BYTES  - TVBUF + ROW*32 + (COL DIV 9).
02000	L:	ASH 1,5
02100		ADD 1,TVBUF
02200		IDIVI 2,9
02300		ADD 1,2
02400		HLL 1,[POINT 4,0,-1 ↔ POINT 4,0,03 ↔ POINT 4,0,07
02500		       POINT 4,0,11 ↔ POINT 4,0,15 ↔ POINT 4,0,19
02600		       POINT 4,0,23 ↔ POINT 4,0,27 ↔ POINT 4,0,31]
02700		JUMPN@↔POP2J
02800	BEND
     

00100	;HVCONTRAST(PGON)  -  HORIZONTAL/VERTICAL CONTRAST.
00200	SUBR(HVCONT)
00300	BEGIN HVCONT
00400		R←1 ↔ C←2 ↔ R2←10 ↔ C2←11 ↔ E←13 ↔ V1←14 ↔ V2←15
00500	
00600	;INITIALIZATION - SETUP FIRST EDGE OF THE PGON.
00700	
00800		LAC E,ARG1 ↔ CAR E,1(E) ↔ DAC E,E0# ↔  CW V2,E
00900		LAC -1(V2)↔ADD [XWD 30,30]
01000		CAR R2,↔LSH R2,-6   ↔   CDR C2,↔LSH C2,-6
01100	
01200	;ADVANCE CCW ALONGPGON.
01300	
01400	L0:	DAC V2,V1 ↔ DAC R2,R1# ↔ DAC C2,C1# ↔ CCW V2,E
01500		LAC -1(V2)↔ADD [XWD 30,30]
01600		CAR R2,↔LSH R2,-6   ↔   CDR C2,↔LSH C2,-6
01700	
01800	;SELECT HORIZONTAL OR VERTICAL.
01900	
02000		CAMN R2,R1 ↔ JRST HORZNT
02100		CAMN C2,C1 ↔ JRST VERTCL
02200		OUTSTR[ASCIZ/HVCONT ¬HV./]
02300	L1:	CCW E,V2↔CAME E,E0↔JRST L0
02400	
02500	;VERTEX CONTRAST.
02600	L2:	NAP 0,-1(E)
02700		CCW V1,E
02800		CCW E,V1
02900		NAP 1,-1(E)
03000		SUB 1,0↔DAP 1,2(V1)
03100	
03200		NAP 1,-1(E)↔MOVMS↔MOVMS 1↔CAMG 0,1↔EXCH 0,1
03300		SETO 2,↔CAML 0,VCUT↔CAML 1,VCUT↔SETZ 2,
03400		DIP 2,2(V1)			;MARK TRANSITIONAL VERTEX.
03500	
03600		CAME E,E0↔JRST L2↔POP1J
     

00100	;HORIZONTAL CASE LEFT TO RIGHT.
00200	HORZNT:
00300		LAC R,R1
00400		LAC C,C1 ↔ LAC 5,C2
00500		CAML C,C2 ↔ EXCH C,5	;GET FAR LEFT IN C.
00600		LAC 6,C ↔ SUB 5,C	;COLUMN DIFFERENCE.
00700	
00800	;SETUP TVBUF BYTE POINTERS 1 INSIDE, 3 OUTSIDE.
00900		JSP PIXPTR+3↔LAC 3,1
01000		SUBI 1,=32 ↔ SKIPE FLGSIX ↔ SUBI 1,=16
01100		CAME 6,C1 ↔ EXCH 1,3 ↔ LAC 6,5
01200	
01300	;ACCUMULATE INTENSITIES ALONG THE EDGE.
01400		SETZB 2,4↔ILDB 1↔ADDM 2↔ILDB 3↔ADDM 4↔  SOJG 5,.-4
01500	
01600	;SET ABOVE THE TOP OR BELOW THE BOTTOM TO UTTER DARKNESS.
01700		SKIPE R2↔CAIN R2,=216↔SETZ 4,
01800	
01900	;COMPUTE AND SAVE AVERAGE INTENSITIES AND CONTRAST.
02000		IDIV 2,6↔DIP 2,2(E)	;INSIDE CCW V1 TO V2.
02100		IDIV 4,6↔DAP 4,2(E)	;OUTSIDE CW V1 TO V2.
02200		SUB 2,4↔DAP 2,-1(E)	;CONTRAST INSIDE MINUS OUTSIDE.
02300		DIP 6,-1(E)↔ JRST L1
02400	
02500	;VERTICAL CASE TOP TO BOTTOM.
02600	VERTCL:
02700		LAC C,C1 ↔ LAC R,R1 ↔ LAC 5,R2
02800		CAML R,R2 ↔ EXCH R,5	;GET UPPERMOST ROW.
02900		LAC 6,R ↔ SUB 5,R	;ROW DIFFERENCE.
03000	
03100	;SETUP TVBUF BYTE POINTERS 1 INSIDE, 3 OUTSIDE.
03200		JSP PIXPTR+3↔TLO 1,7↔LAC 3,1	;INDEXED BY AC-7.
03300		IBP 1 ↔ TLC  3,(44B5)	;FLIP 'EM.
03400		TLNN 3,(44B5)↔SOSA 3	;DECREM BYTE POINTER.
03500		TLC  3,(44B5)		;STATUS QUO ANTE.
03600		CAME 6,R1 ↔ EXCH 1,3 ↔ LAC 6,5
03700	
03800	;ACCUMULATE INTENSITIES ALONG THE EDGE.
03900		SETZB 2,4↔SETZ 7,
04000		MOVEI =32↔SKIPE FLGSIX↔MOVEI =48↔DAP .+5    ;ROW WORD WIDTH.
04100		LDB 1↔ADDM 2↔LDB 3↔ADDM 4↔ADDI 7,0↔  SOJG 5,.-5
04200	
04300	;SET BEYOND THE LEFT OR RIGHT TO UTTER DARKNESS.
04400		SKIPE C2↔CAIN C2,=288↔SETZ 4,
04500	
04600	;COMPUTE AND SAVE AVERAGE INTENSITIES AND CONTRAST.
04700		IDIV 2,6↔DIP 2,2(E)	;INSIDE CCW V1 TO V2.
04800		IDIV 4,6↔DAP 4,2(E)	;OUTSIDE CW V1 TO V2.
04900		SUB 2,4↔DAP 2,-1(E)	;CONTRAST INSIDE MINUS OUTSIDE.
05000		DIP 6,-1(E)↔  JRST L1 ↔	LIT↔VAR
05100	BEND
     

00100	; ARC CONTRAST.
00200	SUBR(ARCONT)
00300	BEGIN ARCONT
00400		ACCUMULATORS{U1,U2,V1,V2,E,E0,N}
00500	
00600		LAC E,ARG1	;FIRST EDGE OF AN ARC PGON.
00700		CAR E,1(E)
00800		DAC E,E0
00900		CW V2,E
01000	
01100	L1:	LAC V1,V2↔CCW V2,E
01200		ARC U1,V1↔ARC U2,V2
01300	
01400		SETZ↔MOVEI N,1
01500	
01600		CCW U1,U1↔ADD 2(U1)↔CCW U1,U1
01700		CAME U1,U2↔AOJA N,.-4
01800	
01900		CAR 2,0 ↔ IDIV 2,N ↔ DIP 2,2(E)
02000		CDR 0,0 ↔ IDIV 0,N ↔ DAP 0,2(E)
02100		SUB 2,0 ↔ DAP  2,-1(E)
02200	
02300		CCW E,V2↔CAME E,E0↔JRST L1
02400	
02500	;VERTEX CONTRAST.
02600	L2:	NAP 0,-1(E)↔CCW V1,E
02700		CCW E,V1↔NAP 1,-1(E)
02800		SUB 1,0↔DAP 1,2(V1)
02900	
03000		NAP 1,-1(E)↔MOVMS↔MOVMS 1
03100		CAMG 0,1↔EXCH 0,1
03200		SETO 2,↔CAML 0,VCUT↔CAML 1,VCUT↔SETZ 2,
03300		DIP 2,2(V1)			;MARK TRANSITIONAL VERTEX.
03400	
03500		CAME E,E0↔JRST L2↔POP1J
03600	BEND
     

00100	;SUBR MKARCS (ARCV1,ARCV2,DELTA)  -  FROM U1 CCW TO U2.
00200	SUBR(MKARCS)
00300	BEGIN MKARCS
00400		EXTERN DPYXXX
00500		EXTERN SQRT; CLOBBERS AC1 THRU AC4.
00600		ACCUMULATORS{D,U1,U2,V1,V2,A,B,C,S12,E,U,V}
00700		LAC V1,ARG3↔LAC V2,ARG2↔SETZM AVCNT#
00800	
00900	;CHECK FOR TRIVAIL CASE.
01000	L0:	ARC U1,V1↔ARC U2,V2
01100		CCW E,U1↔CCW 0,E↔CAMN 0,U2↔GO L3
01200	
01300	;COMPUTE NORMALIZED ARC EDGE COEFFICIENTS.
01400		ROW A,V1↔FLO A,		; A ← Y1.
01500		COL B,V2↔FLO B,		; B ← X2.
01600		COL C,V1↔FLO C,		; C ← X1.
01700		ROW D,V2↔FLO D,		; D ← Y2.
01800		LAC 1,B↔FMPR 1,A	; 1 ← X2*Y1.
01900		FSBR A,D↔FSBR B,C	; A ← Y1-Y2.   B ← X2-X1.
02000		FMPR C,D↔FSBR C,1	; C ← X1*Y2 - X2*Y1.
02100		LAC 0,A↔FMPR 0,0↔LAC 1,B↔FMPR 1,1↔FADR 1,0
02200		CALL SQRT,1↔FDVR A,1↔FDVR B,1↔FDVR C,1
02300	
     

00100	;SET 'EM UP FOR AN ARC PASS.
00200		ARC U1,V1↔ARC U2,V2
00300		SETZM DMAX#↔SETZM DMIN#
00400		SETZM VMAX#↔SETZM VMIN#
00500		SETZM MAXCON#
00600	;GO FROM U1 CCW TO U2 AND FIND THE U FURTHEST OFF THE ARC-EDGE.
00700	L1:	CCW E,U1↔CCW U1,E↔CAMN U1,U2↔GO L2
00800		COL 0,U1↔FLO 0,↔ROW 1,U1↔FLO 1,
00900		FMPR 0,A↔FMPR 1,B↔LAC D,C↔FADR D,0↔FADR D,1
01000		CAMGE D,DMIN↔GO [DAC U1,VMIN↔DAC D,DMIN↔GO .+1]
01100		CAMLE D,DMAX↔GO [DAC U1,VMAX↔DAC D,DMAX↔GO .+1]
01200	;KEEP TRACK OF MAXIMUM EDGE CONTRAST ALONG ARC.
01300		NAP 0,-1(E)↔MOVM↔CAMLE MAXCON↔DAC MAXCON↔GO L1
01400	
01500	;WHEN EXTREMA EXCEED ARCWID[MAXCON] THEN FORM ARC-POINTS.
01600	L2:	LAC U,VMIN↔LACM DMIN
01700		CAMGE DMAX↔LAC U,VMAX↔CAMGE DMAX↔LAC DMAX
01800		LAC 1,MAXCON↔CAMGE ARCWID(1)↔GO L3
01900		
02000	;OLDE ESPLIT: →CW→ V2...D...AV...E...V1 ←CCW←
02100		CALL GETBLK↔DAC 1,E
02200		CALL GETBLK↔DAC 1,V↔AOS AVCNT
02300		ARC. U,V↔ARC. V,U↔LAC -1(U)↔DAC -1(V)
02400		CW D,V2↔CCW. D,V↔CW. V,D
02500		CW. E,V↔CCW. E,V1
02600		CW. V1,E↔CCW. V,E
02700		LAC V2,V↔SKIPN FLGXXX↔GO L0
02800		SAVAC(15)↔PUSHJ P,DPYXXX↔GETAC(15)↔GO L0
02900	
03000	;ADVANCE CCW AN ARC-EDGE OR EXIT.
03100	L3:	CAMN V2,ARG2↔RET3
03200		LAC V1,V2↔CCW E,V2↔CCW V2,E↔GO L0
03300	BEND
     

00100	;PGON ← MKVIC;
00200	SUBR(MKVIC)
00300	BEGIN MKVIC
00400	
00500		ACCUMULATORS{A2,A3,RC,MASK,I,PTR,D,E,A12,V}
00600		LAC I,ISAVED
00700		CDR PTR,ARG1
00800		SLIMZ I↔LAP PAC↔DAC PACPTR#; PAC POINTER INDEXED BY I.
00900	
01000	;FIND THE ROW & COL OF THE UPPER LEFT MOST VSEG.
01100	L1:	SKIPE 1,VSEG(I)↔GO L2
01200		AOS I↔CAIE I,=1728↔GO L1
01300		SETZ 1,↔RET0;EMPTY.
01400	
01500	L2:	DAC I,ISAVED↔JFFO 1,.+1↔SLIMZ MASK,400000
01600		MOVNS 2↔LSH MASK,(2)↔MOVNS 2
01700		LAC RC,I↔ANDI RC,7↔IMULI RC,=36↔ADD RC,2	;COLUMN.
01800		LAC I↔LSH -3↔DIP RC↔LSH RC,6			;ROW.
01900	
02000	;DISTINGUISH BLOBS FROM HOLES.
02100		SETZM HOLE#
02200		TDNN MASK,@PACPTR; HOLE OR BLOB ?
02300		SETOM HOLE#;HOLE'A'COMING.
02400	
02500	;...AND HEAD SOUTH.
02600		DAC  RC,RCMIN#↔SETZM RCMAX#↔SETZ V,↔SETZM ECNT#
02700		PUSHJ P,FOLLOW↔LAC V,V0↔CCW. V,E↔CW. E,V
02800	;MAKE & RETURN VIC POLYGON.
02900		CALL GETBLK↔DAC 1,PTR
03000		LAC 1,ECNT↔SKIPE HOLE#↔MOVNS 1 ; -CNT INDICATES A HOLE.
03100		DAC 1,-1(PTR)↔CCW E,V↔DIP E,1(PTR)↔LAC 1,PTR
03200	L3:	RET0
03300	
     

00100	;THE SUB-OPERATIONS OF MKVIC.
00200	
00300	DEFINE	TRY (SEG,YES) {
00400		LAC SEG(I)↔TDZN MASK↔GO .+3↔DAC SEG(I)↔GO YES}
00500	DEFINE	LEFT	{SUBI RC,100↔ROT MASK,1↔CAIN MASK,1↔SOS I}
00600	DEFINE	RIGHT	{ADDI RC,100↔ROT MASK,-1↔SKIPG MASK↔AOS I}
00700	DEFINE	UP 	{SUB RC,[1B11]↔SUBI I,8}
00800	DEFINE	DOWN  	{ADD RC,[1B11]↔ADDI I,8}
00900	DEFINE	DEL $ (A,B){LAC D,[XWD 0$A$30,0$B$30]}
01000	
01100	;CREATE NEW EDGE AND VERTEX.
01200	TURN:	0
01300		ADD D,RC
01400		AOS 2,ECNT
01500	
01600	;VERTEX
01700		CALL GETBLK
01800		SKIPN V↔GO[DAC 1,V0#↔DAC 1,V↔GO T2]
01900		DAC 1,V↔DIP 2,(V)
02000		CCW. V,E↔CW. E,V
02100	T2:	DAC D,-1(V)
02200		CAMLE D,RCMAX
02300		GO[DAC D,RCMAX↔DAC V,V1#↔GO .+1]
02400	
02500	;EDGE
02600		CALL GETBLK
02700		DAC 1,E↔DIP 2,(E)
02800		CCW. E,V↔CW. V,E
02900		GO @TURN
     

00100	;THE ALCHEMIST OF MKVIC -
00200	;	- converts bits of lead into golden line segments.
00300	
00400	NORTH:	ADD D,[1B11]↔JSR TURN
00500	NORTH2:	LEFT↔DEL(+,-)↔	TRY HSEG,WEST
00600		RIGHT↔UP↔	TRY VSEG,NORTH2
00700		DOWN↔DEL(+,+)↔	TRY HSEG,EAST↔FATAL(NORTH)
00800	NORTH3:	JSR TURN↔LEFT
00900	NORTH4:	UP↔DEL(+,-)↔	TRY HSEG,WEST↔GO NORTH4
01000	
01100	
01200	WEST:	ADDI D,100↔JSR TURN
01300	WEST2:	CAMN RC,RCMIN↔POPJ P,;TRY FOR E.O.VIC.
01400	FOLLOW:	DEL(+,+)↔	TRY VSEG,SOUTH
01500		LEFT↔		TRY HSEG,WEST2
01600		RIGHT↔UP↔DEL(-,+)↔TRY VSEG,NORTH↔FATAL(WEST)
01700	
01800	
01900	SOUTH:	JSR TURN
02000	SOUTH2:	DOWN↔DEL(-,+)
02100		CAR RC↔CAIN =216B29↔GO EAST3
02200				TRY HSEG, EAST
02300				TRY VSEG,SOUTH2
02400		LEFT↔DEL(-,-)↔	TRY HSEG,WEST↔	FATAL(SOUTH)
02500	
02600	
02700	EAST:	JSR TURN
02800	EAST2:	RIGHT↔DEL(-,-)
02900		CDR RC↔CAIN =288B29↔GO NORTH3
03000		UP↔		TRY VSEG,NORTH
03100		DOWN↔		TRY HSEG,EAST2
03200		DEL(+,-)↔	TRY VSEG,SOUTH↔FATAL(EAST)
03300	EAST3:	JSR TURN↔UP
03400	EAST4:	RIGHT↔DEL(-,-)
03500		CDR RC↔CAIN =288B29↔GO[DOWN↔GO NORTH3]
03600				TRY VSEG,NORTH↔GO EAST4
     

00100	;MAKE PROTO ARC POLYGON USING V0 AND V1.
00200	SUBR(MKPAP)
00300		AV1←MASK↔AV2←I
00400		CALL GETBLK↔DAC 1,PTR
00500		CALL GETBLK↔DAC 1,E
00600		CALL GETBLK↔DAC 1,D
00700		CALL GETBLK↔DAC 1,AV1↔LAC 1,V0↔ARC. 1,AV1↔ARC. AV1,1
00800		LAC -1(1)↔DAC -1(AV1)
00900		CCW. E,AV1↔CW. AV1,E↔CCW. AV1,D↔CW. D,AV1
01000		CALL GETBLK↔DAC 1,AV2↔LAC 2,V1↔ARC. 2,AV2↔ARC. AV2,2
01100		LAC -1(2)↔DAC -1(AV2)
01200		CCW. D,AV2↔CW. AV2,D↔CCW. AV2,E↔CW. E,AV2
01300		DIP E,1(PTR)↔LAC 1,PTR↔RET0
01400	BEND
     

00100	;FARCL(PGON) - FIT ARCS LINEAR.
00200	SUBR(FARCL)
00300	BEGIN FARCL
00400		X←1
00500		ACCUMULATORS{Y,SX,SY,XX,YY,XY,N,E,U1,U2,V1,V2}
00600		DAC 12,AC12
00700	
00800	;Clear the Locus of all the Arc Vertices.
00900		LAC E,ARG1↔CAR E,1(E)↔DAC E,E0#
01000		CCW V1,E ↔ SETZM -1(V1)
01100		CCW E,V1 ↔ CAME E,E0↔JRST .-4
01200	
01300	;Advance along Polygon.
01400		CW V2,E
01500	L1:	LAC V1,V2↔CCW V2,E
01600		ARC U1,V1↔ARC U2,V2
01700		CW U1,U1↔CW U1,U1
01800		CW U1,U1↔CW U1,U1
01900		CW U1,U1↔CW U1,U1
02000		CCW U2,U2↔CCW U2,U2
02100		CCW U2,U2↔CCW U2,U2
02200		CCW U2,U2↔CCW U2,U2
02300	
02400	;Arc Scan Initialization.
02500		LAC [XWD SX,SY]↔SETZ SX,↔BLT N↔JRST .+3
02600	;Advance along VIC within the ARC.
02700	L2:	CCW U1,U1↔CCW U1,U1
02800	;Accumulate a Point.
02900		CDR X,-1(U1)↔FLO X,↔CAR Y,-1(U1)↔FLO Y,
03000		FAD SX,X ↔ FAD SY,Y
03100		LAC X ↔ FMP Y ↔ FAD XY,0
03200		FMP X,X ↔ FAD XX,X
03300		FMP Y,Y ↔ FAD YY,Y
03400		CAME U1,U2↔AOJA N,L2↔AOS N
     

00100	;Compute symetric least squares line coefficients.
00200	; Q ← N*XY - SY*SX.
00300	; A ← Q + SY*SY - N*YY.
00400	; B ← Q + SX*SX - N*XX.
00500	; C ← SX*YY + SY*XX - XY*(SX+SY).
00600	
00700	L3:	LAC 2,SX↔FMP 2,YY
00800		LAC 0,SY↔FMP 0,XX↔FAD 2,0
00900		LAC SX↔FAD SY↔FMP XY↔FSB 2,0↔DAC 2,CCCC#
01000	
01100		FSC N,233↔FMP XX,N↔FMP XY,N↔FMP YY,N	;all the N terms.
01200		LAC SX↔FMP SY↔FSB XY,0				;Q in XY.
01300	
01400		FMP SY,SY↔FAD SY,XY↔FSB SY,YY↔DAC SY,AAAA#
01500		FMP SX,SX↔FAD SX,XY↔FSB SX,XX↔DAC SX,BBBB#
01600	
01700		FMP SY,SY↔FMP SX,SX↔FAD SX,SY
01800		MOVSI(1.0)↔FDVR SX↔DAC QQQQ#	;PSEUDO NORMALIZATION.
01900	
02000	;Solve for the Locii where perpendiculars dropped from
02100	;the arc-edge hit the fitted line.
02200	; Q ← 1/(A*A + B*B).
02300	; D ← (B*X1 - A*Y1).
02400	; X ← (B*D - A*C)*Q.
02500	; Y ←-(A*D + B*C)*Q.
02600	
02700	L4:	ARC U1,V1
02800		CDR X,-1(U1)↔FLO X,↔CAR Y,-1(U1)↔FLO Y,
02900		FMP X,BBBB↔FMP Y,AAAA↔FSBR X,Y↔LACN Y,X		;DDDD.
03000		FMP X,BBBB↔FMP Y,AAAA
03100		LAC AAAA↔FMP CCCC↔FSBR X,↔FMPR X,QQQQ↔247040226000;FIX
03200		LAC BBBB↔FMP CCCC↔FSBR Y,↔FMPR Y,QQQQ↔247100226000
03300		DIP Y,X↔ADDM X,-1(V1)
03400	
03500		ARC U2,V2
03600		CDR X,-1(U2)↔FLO X,↔CAR Y,-1(U2)↔FLO Y,
03700		FMP X,BBBB↔FMP Y,AAAA↔FSBR X,Y↔LACN Y,X		;DDDD.
03800		FMP X,BBBB↔FMP Y,AAAA
03900		LAC AAAA↔FMP CCCC↔FSBR X,↔FMPR X,QQQQ↔247040226000;FIX
04000		LAC BBBB↔FMP CCCC↔FSBR Y,↔FMPR Y,QQQQ↔247100226000
04100		DIP Y,X↔ADDM X,-1(V2)
04200	
04300		CCW E,V2↔CAME E,E0↔JRST L1
04400		LAC 12,AC12↔POP1J
04500	BEND
     

00100	END